home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / darc31.zip / DEARCLZW.PAS < prev    next >
Pascal/Delphi Source File  |  1993-01-04  |  12KB  |  613 lines

  1. (**
  2.  *
  3.  *  Module:       dearclzw.pas
  4.  *  Description:  DEARC Lempel-Ziv-Welch decompression routines
  5.  *                (that is,  unsquashing and uncrunching)
  6.  *
  7.  *  Revision History:
  8.  *    7-26-88: unitized for Turbo v4.0
  9.  *
  10. **)
  11.  
  12.  
  13. unit dearclzw;
  14.  
  15. interface
  16. uses
  17.   dearcabt,
  18.   dearcglb,
  19.   dearcio,
  20.   dearcunp;
  21.  
  22. procedure init_ucr ( i : integer );
  23. function getc_ucr : integer;
  24. procedure decomp ( SquashFlag : integer );
  25.  
  26. implementation
  27.  
  28. (*
  29.  *  definitions for uncrunch / unsquash
  30.  *)
  31. Const
  32.    TABSIZE   = 4096;
  33.    TABSIZEM1 = 4095;
  34.    NO_PRED : word  = $FFFF;
  35.    EMPTY   : word  = $FFFF;
  36.  
  37. Type
  38.    entry = record
  39.               used         : boolean;
  40.               next         : integer;
  41.               predecessor  : integer;
  42.               follower     : byte
  43.            end;
  44.  
  45. Var
  46.    stack       : array [0..TABSIZEM1] of byte;
  47.    sp          : integer;
  48.    string_tab  : array [0..TABSIZEM1] of entry;
  49.  
  50. Var
  51.    code_count : integer;
  52.    code       : integer;
  53.    firstc     : boolean;
  54.    oldcode    : integer;
  55.    finchar    : integer;
  56.    inbuf      : integer;
  57.    outbuf     : integer;
  58.    newhash    : boolean;
  59.  
  60. (*
  61.  *  definitions for dynamic uncrunch
  62.  *)
  63. Const
  64.   Crunch_BITS = 12;
  65.   Squash_BITS = 13;
  66.   HSIZE = 8192;
  67.   INIT_BITS = 9;
  68.   FIRST = 257;
  69.   CLEAR = 256;
  70.   HSIZEM1 = 8191;
  71.   BITSM1 = 12;
  72.  
  73.   RMASK : array[0..8] of byte = ($00, $01, $03, $07, $0f, $1f, $3f, $7f, $ff);
  74.  
  75. Var
  76.   bits,
  77.   n_bits,
  78.   maxcode    : integer;
  79.   prefix     : array[0..HSIZEM1] of integer;
  80.   suffix     : array[0..HSIZEM1] of byte;
  81.   buf        : array[0..BITSM1]  of byte;
  82.   clear_flg  : integer;
  83.   stack1     : array[0..HSIZEM1] of byte;
  84.   free_ent   : integer;
  85.   maxcodemax : integer;
  86.   offset,
  87.   sizex      : integer;
  88.  
  89.  
  90. (**
  91.  *
  92.  *  Name:         function h
  93.  *  Description:  calculate hash value for LZW compression
  94.  *                thanks to Bela Lubkin
  95.  *  Parameters:   value -
  96.  *                  pred, foll : integer - pred and follower bytes
  97.  *  Returns:      new hash value
  98.  *
  99. **)
  100. function h(pred, foll : integer) : integer;
  101. { pbr - removed messy real-to-int stuff - not necessary in TP4 }
  102. var
  103.   Local : longint;
  104.   V     : word;
  105. begin
  106.   if not newhash then
  107.     Local := (pred + foll) or $0800
  108.   else
  109.     Local := (pred + foll) * 15073;
  110.  
  111.   h := integer(local and $0FFF);
  112. end;
  113.  
  114.  
  115. (**
  116.  *
  117.  *  Name:         function eolist
  118.  *  Description:  find end of an LZW chain
  119.  *  Parameters:   value -
  120.  *                  index : integer - start of chain
  121.  *  Returns:      last entry in chain
  122.  *
  123. **)
  124. function eolist(index : integer) : integer;
  125. var temp : integer;
  126. begin
  127.   temp := string_tab[index].next;
  128.  
  129.   while temp <> 0 do
  130.     begin
  131.       index := temp;
  132.       temp := string_tab[index].next
  133.     end;
  134.  
  135.   eolist := index
  136. end; (* func eolist *)
  137.  
  138.  
  139. (**
  140.  *
  141.  *  Name:         function hash
  142.  *  Description:  add pred/foll pair to LZW hash table
  143.  *  Parameters:   value -
  144.  *                  pred, foll : integer - pair to add
  145.  *  Returns:      new pred val
  146.  *
  147. **)
  148. function hash(pred, foll : integer) : integer;
  149. var
  150.   local     : integer;
  151.     tempnext  : integer;
  152. begin
  153.   local := h(pred, foll);
  154.  
  155.   if not string_tab[local].used then
  156.     hash := local
  157.   else
  158.     begin
  159.       local := eolist(local);
  160.       tempnext := (local + 101) and $0FFF;
  161.  
  162.       while string_tab[tempnext].used do
  163.         begin
  164.           tempnext := tempnext + 1;
  165.           if tempnext = TABSIZE then
  166.             tempnext := 0
  167.         end;
  168.  
  169.       string_tab[local].next := tempnext;
  170.       hash := tempnext
  171.     end
  172. end; (* func hash *)
  173.  
  174.  
  175. (**
  176.  *
  177.  *  Name:         procedure upd_tab
  178.  *  Description:  update LZW hash table entry
  179.  *  Parameters:   value -
  180.  *                  pred, foll : integer - pair to update
  181.  *
  182. **)
  183. procedure upd_tab(pred, foll : integer);
  184. begin
  185.   with string_tab[hash(pred, foll)] do
  186.     begin
  187.       used := TRUE;
  188.       next := 0;
  189.       predecessor := pred;
  190.       follower := foll
  191.     end
  192. end; (* proc upd_tab *)
  193.  
  194.  
  195. (**
  196.  *
  197.  *  Name:         function gocode : integer
  198.  *
  199. **)
  200. function gocode : integer;
  201. label
  202.   exit;
  203. var
  204.   localbuf  : integer;
  205.   returnval : integer;
  206. begin
  207.   if inbuf = EMPTY then
  208.     begin
  209.       localbuf := getc_unp;
  210.  
  211.       if localbuf = -1 then
  212.         begin
  213.           gocode := -1;
  214.           goto exit                       (******** was "exit" ************)
  215.         end;
  216.  
  217.       localbuf := localbuf and $00FF;
  218.       inbuf := getc_unp;
  219.       if inbuf = -1 then
  220.         begin
  221.           gocode := -1;
  222.           goto exit                       (******** was "exit" ************)
  223.         end;
  224.  
  225.       inbuf := inbuf and $00FF;
  226.       returnval := ((localbuf shl 4) and $0FF0) + ((inbuf shr 4) and $000F);
  227.       inbuf := inbuf and $000F
  228.     end
  229.   else
  230.     begin
  231.       localbuf := getc_unp;
  232.       if localbuf = -1 then
  233.         begin
  234.           gocode := -1;
  235.           goto exit                       (******** was "exit" ************)
  236.         end;
  237.  
  238.       localbuf := localbuf and $00FF;
  239.       returnval := localbuf + ((inbuf shl 8) and $0F00);
  240.       inbuf := EMPTY
  241.     end;
  242.   gocode := returnval;
  243.  
  244. exit:
  245.  
  246. end; (* func gocode *)
  247.  
  248.  
  249. (**
  250.  *
  251.  *  Name:         procedure push
  252.  *  Description:  push a char onto LZW 'pending' stack
  253.  *  Parameters:   value -
  254.  *                  c : integer - value to push
  255.  *
  256. **)
  257. procedure push(c : integer);
  258. begin
  259.   stack[sp] := c;
  260.   sp := sp + 1;
  261.  
  262.   if sp >= TABSIZE then
  263.     abort('Stack overflow')
  264. end; (* proc push *)
  265.  
  266.  
  267. (**
  268.  *
  269.  *  Name:         function pop : integer
  270.  *  Description:  pop a character from LZW 'pending' stack
  271.  *  Parameters:   none
  272.  *  Returns:      character popped or EMPTY
  273.  *
  274. **)
  275. function pop : integer;
  276. begin
  277.   if sp > 0 then
  278.     begin
  279.       sp := sp - 1;
  280.       pop := stack[sp]
  281.     end
  282.   else
  283.     pop := EMPTY
  284. end; (* func pop *)
  285.  
  286.  
  287. (**
  288.  *
  289.  *  Name:         procedure init_tab
  290.  *  Description:  initialize LZW string table
  291.  *  Parameters:   none
  292.  *
  293. **)
  294. procedure init_tab;
  295. var
  296.   i : integer;
  297. begin
  298.   FillChar(string_tab, sizeof(string_tab), 0);
  299.  
  300.   for i := 0 to 255 do
  301.     upd_tab(NO_PRED, i);
  302.  
  303.   inbuf := EMPTY;
  304. end; (* proc init_tab *)
  305.  
  306.  
  307. (**
  308.  *
  309.  *  Name:         procedure init_ucr
  310.  *  Description:  init LZW routines
  311.  *  Parameters:   value -
  312.  *                  i : integer - hash seed
  313.  *
  314. **)
  315. procedure init_ucr(i:integer);
  316. begin
  317.   newhash := i = 1;
  318.   sp := 0;
  319.   init_tab;
  320.   code_count := TABSIZE - 256;
  321.   firstc := TRUE
  322. end; (* proc init_ucr *)
  323.  
  324.  
  325. (**
  326.  *
  327.  *  Name:         function getc_ucr : integer
  328.  *  Description:  get next (uncompressed) LZW character
  329.  *  Parameters:   none
  330.  *  Returns:      next character
  331.  *
  332. **)
  333. function getc_ucr : integer;
  334. label exit;
  335. var c       : integer;
  336.     code    : integer;
  337.     newcode : integer;
  338. begin
  339.   if firstc then
  340.     begin
  341.       firstc := FALSE;
  342.       oldcode := gocode;
  343.       finchar := string_tab[oldcode].follower;
  344.       getc_ucr := finchar;
  345.       goto exit                         (******** was "exit" ************)
  346.     end;
  347.  
  348.   if sp = 0 then
  349.     begin
  350.       newcode := gocode;
  351.       code := newcode;
  352.       if code = -1 then
  353.         begin
  354.           getc_ucr := -1;
  355.           goto exit                     (******** was "exit" ************)
  356.         end;
  357.  
  358.       if not string_tab[code].used then
  359.         begin
  360.           code := oldcode;
  361.           push(finchar)
  362.         end;
  363.  
  364.       while string_tab[code].predecessor <> NO_PRED do
  365.         with string_tab[code] do
  366.           begin
  367.             push(follower);
  368.             code := predecessor
  369.           end;
  370.  
  371.       finchar := string_tab[code].follower;
  372.       push(finchar);
  373.  
  374.       if code_count <> 0 then
  375.         begin
  376.           upd_tab(oldcode, finchar);
  377.           code_count := code_count - 1
  378.         end;
  379.  
  380.       oldcode := newcode
  381.     end;
  382.  
  383.   getc_ucr := pop;
  384.  
  385. exit:
  386.  
  387. end; (* func getc_ucr *)
  388.  
  389.  
  390. (**
  391.  *
  392.  *  Name:         function getcode : integer
  393.  *  Description:
  394.  *  Parameters:   var -
  395.  *
  396.  *                value -
  397.  *
  398.  *  Returns:
  399.  *
  400. **)
  401. function getcode : integer;
  402. label
  403.   next, exit;
  404. var
  405.   code, r_off, bitsx : integer;
  406.   bp : byte;
  407. begin
  408.   if firstch then
  409.     begin
  410.       offset := 0;
  411.       sizex := 0;
  412.       firstch := false;
  413.     end;
  414.  
  415.   bp := 0;
  416.  
  417.   if (clear_flg > 0) or (offset >= sizex) or (free_ent > maxcode) then
  418.     begin
  419.       if free_ent > maxcode then
  420.         begin
  421.           n_bits := n_bits + 1;
  422.           if n_bits = BITS then
  423.             maxcode := maxcodemax
  424.           else
  425.             maxcode := (1 shl n_bits) - 1;
  426.         end;
  427.  
  428.       if clear_flg > 0 then
  429.         begin
  430.           n_bits := INIT_BITS;
  431.           maxcode := (1 shl n_bits) - 1;
  432.           clear_flg := 0;
  433.         end;
  434.  
  435.       for sizex := 0 to n_bits-1 do
  436.         begin
  437.           code := getc_unp;
  438.           if code = -1 then
  439.             goto next
  440.           else
  441.             buf[sizex] := code;
  442.         end;
  443.  
  444.       sizex := sizex + 1;
  445.  
  446. next:
  447.  
  448.       if sizex <= 0 then
  449.         begin
  450.           getcode := -1;
  451.           goto exit;
  452.         end;
  453.  
  454.       offset := 0;
  455.       sizex := (sizex shl 3) - (n_bits - 1);
  456.     end;
  457.  
  458.   r_off := offset;
  459.   bitsx := n_bits;
  460.  
  461.   (*
  462.    *  get first byte
  463.    *)
  464.   bp := bp + (r_off shr 3);
  465.   r_off := r_off and 7;
  466.  
  467.   (*
  468.    *  get first part (low order bits)
  469.    *)
  470.   code := buf[bp] shr r_off;
  471.   bp := bp + 1;
  472.   bitsx := bitsx - (8 - r_off);
  473.   r_off := 8 - r_off;
  474.  
  475.   if bitsx >= 8 then
  476.     begin
  477.       code := code or (buf[bp] shl r_off);
  478.       bp := bp + 1;
  479.       r_off := r_off + 8;
  480.       bitsx := bitsx - 8;
  481.     end;
  482.  
  483.   code := code or ((buf[bp] and rmask[bitsx]) shl r_off);
  484.   offset := offset + n_bits;
  485.   getcode := code;
  486.  
  487. exit:
  488.  
  489. end;
  490.  
  491.  
  492. (**
  493.  *
  494.  *  Name:         procedure decomp
  495.  *  Description:  decompress a file with LZW
  496.  *  Parameters:   value -
  497.  *                  SquashFlag : integer - true if Squashing in effect
  498.  *
  499. **)
  500. procedure decomp(SquashFlag : Integer);
  501. label
  502.   next,
  503.   exit;
  504. var
  505.   stackp,
  506.   finchar : integer;
  507.   code,
  508.   oldcode,
  509.   incode : integer;
  510. begin
  511.   if SquashFlag = 0 then
  512.     Bits := crunch_BITS
  513.   else
  514.     Bits := squash_BITS;
  515.  
  516.   if firstch then
  517.     maxcodemax := 1 shl bits;
  518.  
  519.   if SquashFlag = 0 then
  520.     begin
  521.       code := getc_unp;
  522.       if code <> BITS then
  523.         begin
  524.            Writeln( 'File packed with ', Code,
  525.                     ' bits, I can only handle ', Bits);
  526.            Halt(1);
  527.         end;
  528.     end;
  529.  
  530.   clear_flg := 0;
  531.   n_bits := INIT_BITS;
  532.   maxcode := (1 shl n_bits ) - 1;
  533.  
  534.   for code := 255 downto 0 do
  535.     begin
  536.       prefix[code] := 0;
  537.       suffix[code] := code;
  538.     end;
  539.  
  540.   free_ent := FIRST;
  541.   oldcode := getcode;
  542.   finchar := oldcode;
  543.  
  544.   if oldcode = -1 then
  545.     goto exit;
  546.  
  547.   if SquashFlag = 0 then
  548.     putc_ncr(finchar)
  549.   else
  550.     putc_unp(finchar);
  551.  
  552.   stackp := 0;
  553.  
  554.   code := getcode;
  555.   while (code  > -1) do
  556.     begin
  557.       if code = CLEAR then
  558.         begin
  559.           for code := 255 downto 0 do
  560.             prefix[code] := 0;
  561.           clear_flg := 1;
  562.           free_ent := FIRST - 1;
  563.           code := getcode;
  564.           if code = -1 then
  565.             goto next;
  566.         end;
  567. next:
  568.       incode := code;
  569.       if code >= free_ent then
  570.         begin
  571.           stack1[stackp] := finchar;
  572.           stackp := stackp + 1;
  573.           code := oldcode;
  574.         end;
  575.  
  576.       while (code >= 256) do
  577.         begin
  578.           stack1[stackp] := suffix[code];
  579.           stackp := stackp + 1;
  580.           code := prefix[code];
  581.         end;
  582.  
  583.       finchar := suffix[code];
  584.       stack1[stackp] := finchar;
  585.       stackp := stackp + 1;
  586.       repeat
  587.         stackp := stackp - 1;
  588.         If SquashFlag = 0 then
  589.           putc_ncr(stack1[stackp])
  590.         else
  591.           putc_unp(stack1[stackp]);
  592.       until stackp <= 0;
  593.  
  594.       code := free_ent;
  595.  
  596.       if code < maxcodemax then
  597.         begin
  598.           prefix[code] := oldcode;
  599.           suffix[code] := finchar;
  600.           free_ent := code + 1;
  601.         end;
  602.  
  603.       oldcode := incode;
  604.       code := getcode;
  605.     end;
  606.  
  607. exit:
  608.  
  609. end;
  610.  
  611. end.
  612.  
  613.